;; -*- Mode: Lisp; -*-

;;;; TGizmo state recorder
;;; Last Edited: 1/29/93, by KDF

;;; Copyright (c) 1991, Kenneth D. Forbus, Northwestern University,
;;;  and Johan de Kleer, the Xerox Corporation.
;;; All Rights Reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

(defpackage #:bps/tgizmo/states
  (:use #:cl
        #:bps/tgizmo/defs
        #:bps/tgizmo/ineqs
        #:bps/tgizmo/mlang
        #:bps/tgizmo/ineqs
        #:bps/tgizmo/resolve
        #:bps/ltms/all)
  (:export
   #:snapshot
   #:get-state
   #:show-state
   #:report-states
   #:make-state-index
   #:classify-by-field
   #:summarize-state-index
   #:same-state?
   #:find-corresponding-states
   #:summarize-ds-differences
   #:subtract-commonalities))

(in-package #:bps/tgizmo/states)

;; Takes a snapshot of the current LTMS database to allow
;; a previously examined state to be regenerated and for
;; easy comparison of states.

(defun snapshot (title &optional (*tgizmo* *tgizmo*))
  (let ((st (make-state :TITLE title
                        :INDIVIDUALS
                        (mapcan #'make-signed-form
                                (tg-fetch '(Exists ?x)))
                        :VIEW-STRUCTURE
                        (mapcan #'(lambda (vform)
                                    (make-signed-form `(Active ,(cadr vform))))
                                (tg-fetch '(View-Instance ?x)))
                        :PROCESS-STRUCTURE
                        (mapcan #'(lambda (vform)
                                    (make-signed-form `(Active ,(cadr vform))))
                                (tg-fetch '(Process-Instance ?x))))))
    (dolist (comp (tgizmo-comparisons *tgizmo*))
      (cond ((and (listp (car comp))
                  (eq (caar comp) 'D)
                  (eq (cdr comp) 'ZERO)) ;; A Ds value
             (let ((rel (rel-value (car comp) (cdr comp))))
               (unless (member rel '(:BT :??))
                 (push `(,(unkeywordize rel) ,(car comp) ,(cdr comp))
                       (state-Ds-values st)))))
            (t ;; Just a random old inequality
             (let ((rel (rel-value (car comp) (cdr comp))))
               (unless (member rel '(:BT :??))
                 (push `(,(unkeywordize rel) ,(car comp) ,(cdr comp))
                       (state-comparisons st)))))))
    st))

(defun make-signed-form (form)
  (case (label-of form)
        (:TRUE (list form))
        (:FALSE (list `(:NOT ,form)))
        (t nil)))

(defun unkeywordize (symbol)
  (find-symbol (symbol-name symbol) "COMMON-LISP"))

;;;; Showing cached states

(defun get-state (num &optional (*tgizmo* *tgizmo*))
  (dolist (state (tgizmo-states *tgizmo*))
          (when (= (state-title state) num)
                (return-from get-state state))))

(defun show-state (state &key (psvs-inactive? nil)
                              (ds-values? nil)
                              (comparisons? nil)(all? nil)
                              (stream *standard-output*))
  (format stream "~%In state ~A:" (state-title state))
  (let ((actives nil)(inactives nil))
    (dolist (pia (state-process-structure state))
      (if (eq (car pia) :NOT) (push (cadr (cadr pia)) inactives)
          (push (cadr pia) actives)))
    (cond (actives (format stream "~%  Active processes:")
                   (dolist (a actives)
                     (format stream "~%    ~A" a)))
          (t (format stream "~%  No known active processes.")))
    (when (or psvs-inactive? all?)
      (cond (inactives (format stream "~%  Inactive processes:")
                       (dolist (a inactives)
                         (format stream "~%     ~A" a)))
            (t (format stream "~%  No known inactive processes.")))))
  (let ((actives nil)(inactives nil))
    (dolist (pia (state-view-structure state))
      (if (eq (car pia) :NOT) (push (cadr (cadr pia)) inactives)
          (push (cadr pia) actives)))
    (cond (actives (format stream "~%  Active views:")
                   (dolist (a actives)
                     (format stream "~%    ~A" a)))
          (t (format stream "~%  No active views.")))
    (when (or psvs-inactive? all?)
      (cond (inactives (format stream "~%  Inactive views:")
                       (dolist (a inactives)
                         (format stream "~%     ~A" a)))
            (t (format stream "~%  No known inactive views.")))))

  (when (or comparisons? all?)
    (format stream "~%  Known comparisons:")
    (dolist (comp (state-comparisons state))
      (format stream "~%    ~A"
              (apply #'ineq-string comp))))
  (when (or ds-values? all?)
    (format stream "~%  Known Ds values:")
    (dolist (comp (state-Ds-values state))
      (format stream "~%    ~A"
              (Ds-value-string (cadr (cadr comp)) (car comp)))))
  state)

;;;; Report generator for TGIZMO results

(defun report-states (file &optional (*tgizmo* *tgizmo*))
  (with-open-file (fout file :DIRECTION :OUTPUT)
    (format fout "~%TGizmo Report, ~A" (tgizmo-title *tgizmo*))
    (format fout "~% Scenario = ~A~% Measurements = "
            (tgizmo-scenario *tgizmo*))
    (pprint (tgizmo-measurements *tgizmo*) fout)
    (format fout "~% Run under ~A, ~A,~%  on ~A, a ~A (~A)."
            (lisp-implementation-type) (lisp-implementation-version)
            (machine-instance)(machine-type)(machine-version))
    (multiple-value-bind (second minute hour date month year)
        (get-decoded-time)
      (format fout "~% Dumped ~A:~A:~A, ~A/~A/~A"
              hour minute second month date year))
    (dolist (state (reverse (tgizmo-states *tgizmo*)))
      (format fout "~|")
      (show-state state :ALL? t :STREAM fout)
      (format fout "~% ================== ~%"))))

;;;; Sorting states

(defun make-state-index (&optional (*tgizmo* *tgizmo*))
  (let ((top-index (classify-by-field (tgizmo-states *tgizmo*)
                                      (lambda (s) (state-individuals s)))))
    (dolist (ientry top-index top-index)
      (let ((vs-index (classify-by-field (cdr ientry)
                                         (lambda (s) (state-view-structure s)))))
        (dolist (vs-entry vs-index)
          (setf (cdr vs-entry)
                (classify-by-field (cdr vs-entry)
                                   (lambda (s) (state-process-structure s)))))
        (setf (cdr ientry) vs-index)))))

(defun classify-by-field (state-list field &aux index entry)
  (dolist (state state-list index)
   (setq entry (assoc state index
                      :TEST #'(lambda (x y)
                                (same-elements? (funcall field x) y))))
   (unless entry (push (setq entry (list (funcall field state))) index))
   (push state (cdr entry))))

(defun summarize-state-index (index &optional (stream *standard-output*))
  (dolist (ientry index)
    (dolist (i (car ientry))
      (format stream "~% ~A" i))
    (dolist (ventry (cdr ientry))
      (dolist (vi (car ventry))
        (format stream "~%   ~A" vi))
      (dolist (pentry (cdr ventry))
        (dolist (pri (car pentry))
          (format stream "~%     ~A" pri))
        (format stream "~%       ~D states." (length (cdr pentry)))))))

;;;; Comparing states

(defun same-state? (s1 s2)
  (and (same-elements? (state-individuals s1)
                       (state-individuals s2))
       (same-elements? (state-view-structure s1)
                       (state-view-structure s2))
       (same-elements? (state-process-structure s1)
                       (state-process-structure s2))
       (same-elements? (state-ds-values s1)
                       (state-ds-values s2))
       (same-elements? (state-comparisons s1)
                       (state-comparisons s2))))

(defun find-corresponding-states (tg1 tg2 &aux result)
  (dolist (s1 (tgizmo-states tg1) result)
    (dolist (s2 (tgizmo-states tg2))
      (when (same-state? s1 s2)
        (push (cons s1 s2) result)
        (return t)))))

(defun summarize-Ds-differences (state-list
                                 &optional (stream *standard-output*))
  (multiple-value-bind (d-list common)
      (subtract-commonalities
       (mapcar #'(lambda (s) (state-ds-values s)) state-list))
    (format stream "~% Common Ds values:")
    (if common (dolist (comp common)
                 (format stream "~%   ~A"
                         (ds-value-string (cadr (cadr comp)) (car comp))))
        (format stream " None."))
    (do ((states state-list (cdr states))
         (diffs d-list (cdr diffs)))
        ((null states) d-list)
      (format stream "~%   For ~A:" (car states))
      (dolist (comp (car diffs))
        (format stream "~%     ~A"
                (ds-value-string (cadr (cadr comp)) (car comp)))))))

(defun subtract-commonalities (list-of-sets &key (test #'equal) &aux int)
  (setq int (car list-of-sets))
  (dolist (set (cdr list-of-sets))
          (setq int (intersection int set :TEST test)))
  (values (mapcar #'(lambda (set)
                      (set-difference set int :TEST #'equal)) list-of-sets)
          int))
